;;; idrop.el --- Dropdown menu interface - interactive commands.

;;; TODO: insert file and package descripion, history, commentary and license.

;;; Code:

;;; x) requires
(require 'idrop-core)
(require 'idrop-display-methods)

;;; x) client: replace `completing-read'

(defun idrop-completing-read (title
                              collection
                              &optional predicate require-match
                              initial-input hist def inherit-input-method
                              alt-help
                              alt-sets)
  "Popup a idrop menu to read a string. This function can be
used instead `completing-read'.

The variables PROMPT, TABLE, PREDICATE, REQUIRE-MATCH,
INITIAL-INPUT, POP-HIST, DEF and INHERIT-INPUT-METHOD all have the
same meaning is for `completing-read'.

ALT-HELP is unused for now. TODO: Use `alt-help' as well.


ALT-SETS should be nil or an association list that has as keys
groups and as second element an alternative that should go into
this group.
"

  ;; `title'    is the title of the idrop
  ;; `collection' must be filtered through all-completions
  ;; `predicate' is passed to all-completions
  ;; `initial-input' is passed as `idrop-text'
  ;; `hist' is a list of past inputs, not past idrops
  ;; `default' should be added to `collection' as the first item
  ;; TODO: `inherit-input-method' is very interesting
  ;; TODO: `alt-help' will be left unused for now, but is very interesting
  ;; `alt-sets', when non-nil should make `collection', turned into a string-returning keymap and passed to `idrop-popup-menu'
  nil)

;;; x) client: using multiple commands for the same key
;;; TODO: reimplement this using brand new idrop!

(defvar command-selector-last-command nil "$$$$$ FIXME - no doc string")

(defun define-key* (keymap key command)
  "Add COMMAND to the multiple-command binding of KEY in KEYMAP.
Use multiple times to bind different COMMANDs to the same KEY."
  (define-key keymap key (combine-command command (lookup-key keymap key))))

(defun combine-command (command defs)
  "$$$$$ FIXME - no doc string"
  (cond ((null defs) command)
        ((and (listp defs)
              (eq 'lambda (car defs))
              (= (length defs) 4)
              (listp (fourth defs))
              (eq 'command-selector (car (fourth defs))))
         (unless (member `',command (cdr (fourth defs)))
           (setcdr (fourth defs) (nconc (cdr (fourth defs)) `(',command))))
         defs)
        (t
         `(lambda () (interactive) (command-selector ',defs ',command)))))

(defun command-selector (&rest candidates)
  "$$$$$ FIXME - no doc string"
  (if (and (eq last-command this-command) command-selector-last-command)
      (call-interactively command-selector-last-command)
    (let* ((candidate-strings
            (mapcar (lambda (candidate)
                      (format "%s" (if (symbolp candidate)
                                       candidate
                                     (let ((s (format "%s" candidate)))
                                       (if (>= (length s) 7)
                                           (concat (substring s 0 7) "...")
                                         s)))))
                    candidates))
           (selection (idrop candidate-strings)))
      (when selection
        (let ((cmd (nth selection candidates)))
          (call-interactively cmd)
          (setq command-selector-last-command cmd))))))

;;; x) client: Display a popup-menu, like the main menu

;;; TODO: maybe in the future a replacement for `x-popup-menu'

(defconst idrop-menu-button-delimiters
  `(:radio ("[" . "]") :toggle ("(" . ")"))
  "A constant mapping delimiter styles to button styles")

(defun idrop-menu-item-separator-p (item)
  nil)

(defun idrop-menu-item-keybinding-cache-p (item)
  (and (consp item)
       (consp (car item))
       (or (null (caar item))
           (vectorp (caar item)))))

(defun idrop-make-candidate-from-menu-item (item)
  ;; TODO: handle even more exotic properties,
  (when (and (consp item)
             (consp (cdr item)))
    (setq item (cdr item)) ;;Ignores first symbol for the menu item
    (let  (name-prop
           callback-prop
           help-prop
           (selectable-prop t)
           (confirmable-prop t)
           extra-indicator-prop
           cachelist)
      (cond (;; (a) Old format menu item
             (stringp (first item))
             (setq name-prop (first item))
             (cond ((string-match "^--" name-prop)
                    (setq selectable-prop  nil
                          confirmable-prop nil
                          name-prop "--"))
                   (t
                    (setq item (cdr item))
                    ;; Maybe help string
                    (when (and (consp item)
                               (stringp (car item)))
                      (setq help-prop (car item))
                      (setq item (cdr item)))

                    ;; Maybe key binding cache
                    (when (idrop-menu-item-keybinding-cache-p item)
                      (setq cachelist (car item))
                      (setq item (cdr item)))
                    ;; This is the real definition--the function to run.
                    (setq callback-prop item)
                    ;; Get enable property, if any.
                    (when (symbolp item)
                      (let ((prop (get item 'menu-enable)))
                        (setq confirmable-prop (or (null prop)
                                                   prop)))))))

            ((eq (first item) 'menu-item)
             ;; (b) New format menu item
             (setq name-prop (second item))
             (cond (;; (b1) a separator
                    (and (stringp name-prop)
                         (string-match "^--" name-prop))
                    (setq selectable-prop  nil
                          confirmable-prop nil
                          name-prop "--"))
                   (;; (b2) another kind of menu item
                    t
                    (setq callback-prop (third item))
                    (setq item (nthcdr 4 item))
                    ;; Maybe key binding cache
                    (when (idrop-menu-item-keybinding-cache-p item)
                      (setq cachelist (car item))
                      (setq item (cdr item)))
                    (setq confirmable-prop (getf item :enable t))
                    (setq help-prop (getf item :help))
                    (let* ((button-prop (getf item :button))
                           (button-delimiters (and button-prop
                                                   (getf idrop-menu-button-delimiters (car button-prop)))))
                      (when button-delimiters
                        (setq extra-indicator-prop (concat (car button-delimiters)
                                                           (if (eval (cdr button-prop)) "x" " ")
                                                           (cdr button-delimiters)
                                                           " ")))))))
             (t
             ;; (c) Not a menu item
              (return nil)))
      ;; watchout, this deletes the property from the `style-prop'
      (when cachelist
        (setq extra-indicator-prop (cdr cachelist)))

      (idrop-make-candidate :name name-prop
                            :callback (unless (keymapp callback-prop)
                                        callback-prop)
                            :selectable (and callback-prop selectable-prop)
                            :hidden nil
                            :confirmable (and callback-prop confirmable-prop)
                            :extra-indicator extra-indicator-prop
                            :help help-prop
                            :subcandidates (when (keymapp callback-prop)
                                             (list #'idrop-menu-candidates `',callback-prop))))))

(defun idrop-menu-position ()
  nil)

(defun idrop-get-keymap-or-menu (keymap)
  (or (and (keymapp keymap)
           (if (symbolp keymap)
               (symbol-value keymap)
             keymap))
      (cadr keymap)))

(defun idrop-menu-title (keymap)
  (let ((keymapv (idrop-get-keymap-or-menu keymap)))
    (when keymapv
      (find-if #'stringp keymapv))))

(defun idrop-menu-candidates (keymap)
  (let ((keymapv (idrop-get-keymap-or-menu keymap)))
    (remove nil (mapcar #'idrop-make-candidate-from-menu-item
                        keymapv))))

(defun idrop-popup-menu (position menu &optional title)
  "MENU can be a keymap, or a list of keymaps."
  (interactive)
  (idrop-internal (idrop-menu-candidates menu)
                  :title (or
                          (idrop-menu-title menu)
                          (or title "Choose:"))))

(defun idrop-popup-main-menu ()
  (interactive)
  (idrop-popup-menu nil
                    (lookup-key global-map [menu-bar])
                    "Main menu:"))

;;; x) client: use idrop with `hippie-expand' alternatives

(defvar idrop-hippie-expand-max-completions 40
  "Maximum number of `hippie-expand' completions to compute when calling `idrop-hippie-expand'")

(defvar idrop-hippie-expand-show-full-completion-p nil
  "Non-Nil means show the full completion of the candidate in the idrop, when running `idrop-hippie-expand'")

(defun idrop-hippie-expand-next-completion (dummy clearcache)
  "Ignoring the generator seed DUMMY, returns the next
`hippie-expand' completion without modifying the buffer. Resets
itself if CLEARCACHE in non-Nil."
  (let (result)
    (when clearcache
      (setq he-num -1)
      (setq he-tried-table nil))
    (idrop-with-buffer-unmodified
      ;; try a new expansion
      (let* ((last-command 'idrop-hippie-expand-next-completion)
             (this-command last-command))
        (hippie-expand nil)
        (setq result (buffer-substring (if idrop-hippie-expand-show-full-completion-p
                                           he-string-beg
                                         (+ he-string-beg (length he-search-string)))
                                       he-string-end))
        ;; delete the expansion
        (he-reset-string)
        ;; return the expansion, or the whole search-string plus expansion
        result))))

(defun idrop-hippie-expand-test (&optional prefix)
  (interactive "P")
  (message "Returning: %s" (idrop-hippie-expand-next-completion nil prefix)))

(defun idrop-hippie-expand ()
  (interactive)
  (let ((idrop-display-center-p 'down))
    (idrop-internal (cons 'idrop-generator (cons 'idrop-hippie-expand-next-completion nil))
                    :title "hippie:"
                    :fallback-callback-fn #'(lambda ()
                                              (when (idrop-text)
                                                (insert (idrop-text)))))))

;;;  x) client: color picker
;;;  TODO: needs the extra-indicator face override feature

;;;  x) Compatibility to old dropdown-list

(defun dropdown-list (candidates)
  "Popup the idrop for the string list CANDIDATES and return the
  index of the confirmed string, Nil otherwise."
  (interactive)
  (let ((idrop-exit-hook (append idrop-exit-hook
                                 (list #'(lambda ()
                                           (throw 'exit nil)))))
        dropdown-chosen
        (this-command 'idrop-dropdown-list))
    (idrop-internal (mapcar #'(lambda (string)
                                (idrop-make-candidate :name string
                                                      :callback '(setq dropdown-chosen (idrop-candidate-string idrop-confirmed))))
                            candidates)
                    :title "dropdown:")
    (recursive-edit)
    (position dropdown-chosen candidates)))

;;;  x) client: execute command

(defvar idrop-execute-command-cache nil)

(defun idrop-execute-command ()
  "Popup an idrop for interactively executing a command"
  (interactive)
  (let ((commands (or idrop-execute-command-cache
                      (progn
                        (mapatoms #'(lambda (sym)
                                      (when (commandp sym)
                                        (push (idrop-make-candidate :name (symbol-name sym)
                                                                    :callback sym)
                                              idrop-execute-command-cache))))
                        idrop-execute-command-cache))))
    (idrop-internal commands
                    :title "Execute command:")))

;;;  x) client: file finder, ido-style

(defun idrop-file-make-candidates (dir)
  (let ((files (directory-files dir))
        file
        abs
        ret)
    (while files
      (setq file (car files))
      (unless (or (string= file ".")
                  (string= file ".."))
        (setq abs (concat dir "/" file))
        (push (idrop-make-candidate :name file
                                    :callback (when (not (file-directory-p abs))
                                                `(find-file ,abs))
                                    :subcandidates (when (file-directory-p abs)
                                                     `(idrop-file-make-candidates ,abs)))
              ret))
      (setq files (cdr files)))
    ret))

(defvar idrop-find-file-keymap nil
  "A separate keymap used only for idrop-find-file")

(defun idrop-find-file (&optional dir)
  (interactive)
  (let ((dir (or dir
                 default-directory)))
    (idrop-internal (idrop-file-make-candidates dir)
                    dir
                    nil
                    nil
                    idrop-find-file-keymap)))

;;;  x) client: buffer switcher, ido-style
;;;
;;;  TODO: Respect ido buffer customization variables:
;;;
;;;     ido-ignore-buffers
;;;     ido-default-buffer-method
;;;     ido-create-new-buffer
;;;

(defvar idrop-buffer-keymap nil
  "A separate keymap used only for idrop-switch-buffer")

(eval-when-compile
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "C-x b") 'find-file) ;; TODO: Fallback not working
    (define-key map (kbd "C-d") 'idrop-buffer-kill-selected)
    (define-key map (kbd "C-k") 'idrop-buffer-kill-selected)

    (setq idrop-buffer-keymap map)))

(defun idrop-buffer-kill-selected-buffer ()
  (interactive)
  (let ((sel (idrop-delete-candidate (idrop-active)
                                     (idrop-selected (idrop-active)))))
    (when sel
      (push 'refilter idrop-recalculate)
      (kill-buffer (idrop-candidate-string sel)))))

(defun idrop-buffer-make-candidates (&optional method)
  (let ((buffers (buffer-list))
        buffer ret)
    (while buffers
      (setq buffer (car buffers))
      (push (idrop-make-candidate :name (buffer-name buffer)
                                  :hidden (eq (aref (buffer-name buffer) 0)? )
                                  :callback `(,(or method
                                                   'switch-to-buffer) ,buffer))
            ret)
      (setq buffers (cdr buffers)))
    ret))

(defun idrop-buffer-internal (method)
  (idrop-internal (idrop-buffer-make-candidates (cdr method))
                  :title (car method)
                  :subkeymap idrop-buffer-keymap))

(defun idrop-switch-buffer ()
  (interactive)
  (idrop-buffer-internal (cons "Switch to buffer:" 'switch-to-buffer)))

(defun idrop-switch-buffer-other-frame ()
  (interactive)
  (idrop-buffer-internal (cons "Switch to buffer (other frame):" 'switch-to-buffer-other-frame)))

(defun idrop-switch-buffer-other-window ()
  (interactive)
  (idrop-buffer-internal (cons "Switch to buffer (other window):" 'switch-to-buffer-other-window)))

(defun idrop-kill-buffer ()
  (interactive)
  (idrop-buffer-internal (cons "Kill buffer:" 'kill-buffer)))

(defun idrop-insert-buffer ()
  (interactive)
  (idrop-buffer-internal (cons "Insert buffer:" 'insert-buffer)))

(defun idrop-display-buffer ()
  (interactive)
  (idrop-buffer-internal (cons "Display buffer:" 'display-buffer)))

;;; Provides

(provide 'dropdown) ;; for compatibility
(provide 'idrop)

;;; idrop.el ends here

